home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / t / op / misc.t < prev    next >
Text File  |  1998-07-11  |  9KB  |  420 lines
  1. #!./perl
  2.  
  3. # NOTE: Please don't add tests to this file unless they *need* to be run in
  4. # separate executable and can't simply use eval.
  5.  
  6. chdir 't' if -d 't';
  7. @INC = "../lib";
  8. $ENV{PERL5LIB} = "../lib";
  9.  
  10. $|=1;
  11.  
  12. undef $/;
  13. @prgs = split "\n########\n", <DATA>;
  14. print "1..", scalar @prgs, "\n";
  15.  
  16. $tmpfile = "misctmp000";
  17. 1 while -f ++$tmpfile;
  18. END { unlink $tmpfile if $tmpfile; }
  19.  
  20. $CAT = (($^O eq 'MSWin32') ? '.\perl -e "print <>"' : 'cat');
  21.  
  22. for (@prgs){
  23.     my $switch;
  24.     if (s/^\s*(-\w.*)//){
  25.     $switch = $1;
  26.     }
  27.     my($prog,$expected) = split(/\nEXPECT\n/, $_);
  28.     if ($^O eq 'MSWin32') {
  29.       open TEST, "| .\\perl -I../lib $switch >$tmpfile 2>&1";
  30.     }
  31.     else {
  32.       open TEST, "| sh -c './perl $switch' >$tmpfile 2>&1";
  33.     }
  34.     print TEST $prog, "\n";
  35.     close TEST;
  36.     $status = $?;
  37.     $results = `$CAT $tmpfile`;
  38.     $results =~ s/\n+$//;
  39.     $expected =~ s/\n+$//;
  40.     if ( $results ne $expected){
  41.     print STDERR "PROG: $switch\n$prog\n";
  42.     print STDERR "EXPECTED:\n$expected\n";
  43.     print STDERR "GOT:\n$results\n";
  44.     print "not ";
  45.     }
  46.     print "ok ", ++$i, "\n";
  47. }
  48.  
  49. __END__
  50. ()=()
  51. ########
  52. $a = ":="; split /($a)/o, "a:=b:=c"; print "@_"
  53. EXPECT
  54. a := b := c
  55. ########
  56. $cusp = ~0 ^ (~0 >> 1);
  57. $, = " ";
  58. print +($cusp - 1) % 8, $cusp % 8, -$cusp % 8, ($cusp + 1) % 8, "!\n";
  59. EXPECT
  60. 7 0 0 1 !
  61. ########
  62. $foo=undef; $foo->go;
  63. EXPECT
  64. Can't call method "go" on an undefined value at - line 1.
  65. ########
  66. BEGIN
  67.         {
  68.         "foo";
  69.         }
  70. ########
  71. $array[128]=1
  72. ########
  73. $x=0x0eabcd; print $x->ref;
  74. EXPECT
  75. Can't call method "ref" without a package or object reference at - line 1.
  76. ########
  77. chop ($str .= <STDIN>);
  78. ########
  79. close ($banana);
  80. ########
  81. $x=2;$y=3;$x<$y ? $x : $y += 23;print $x;
  82. EXPECT
  83. 25
  84. ########
  85. eval {sub bar {print "In bar";}}
  86. ########
  87. system './perl -ne "print if eof" /dev/null'
  88. ########
  89. chop($file = <>);
  90. ########
  91. package N;
  92. sub new {my ($obj,$n)=@_; bless \$n}  
  93. $aa=new N 1;
  94. $aa=12345;
  95. print $aa;
  96. EXPECT
  97. 12345
  98. ########
  99. %@x=0;
  100. EXPECT
  101. Can't modify hash deref in repeat at - line 1, near "0;"
  102. Execution of - aborted due to compilation errors.
  103. ########
  104. $_="foo";
  105. printf(STDOUT "%s\n", $_);
  106. EXPECT
  107. foo
  108. ########
  109. push(@a, 1, 2, 3,)
  110. ########
  111. quotemeta ""
  112. ########
  113. for ("ABCDE") {
  114.  ⊂
  115. s/./&sub($&)/eg;
  116. print;}
  117. sub sub {local($_) = @_;
  118. $_ x 4;}
  119. EXPECT
  120. Modification of a read-only value attempted at - line 3.
  121. ########
  122. package FOO;sub new {bless {FOO => BAR}};
  123. package main;
  124. use strict vars;   
  125. my $self = new FOO;
  126. print $$self{FOO};
  127. EXPECT
  128. BAR
  129. ########
  130. $_="foo";
  131. s/.{1}//s;
  132. print;
  133. EXPECT
  134. oo
  135. ########
  136. print scalar ("foo","bar")
  137. EXPECT
  138. bar
  139. ########
  140. sub by_number { $a <=> $b; };# inline function for sort below
  141. $as_ary{0}="a0";
  142. @ordered_array=sort by_number keys(%as_ary);
  143. ########
  144. sub NewShell
  145. {
  146.   local($Host) = @_;
  147.   my($m2) = $#Shells++;
  148.   $Shells[$m2]{HOST} = $Host;
  149.   return $m2;
  150. }
  151.  
  152. sub ShowShell
  153. {
  154.   local($i) = @_;
  155. }
  156.  
  157. &ShowShell(&NewShell(beach,Work,"+0+0"));
  158. &ShowShell(&NewShell(beach,Work,"+0+0"));
  159. &ShowShell(&NewShell(beach,Work,"+0+0"));
  160. ########
  161.    {
  162.        package FAKEARRAY;
  163.    
  164.        sub TIEARRAY
  165.        { print "TIEARRAY @_\n"; 
  166.          die "bomb out\n" unless $count ++ ;
  167.          bless ['foo'] 
  168.        }
  169.        sub FETCH { print "fetch @_\n"; $_[0]->[$_[1]] }
  170.        sub STORE { print "store @_\n"; $_[0]->[$_[1]] = $_[2] }
  171.        sub DESTROY { print "DESTROY \n"; undef @{$_[0]}; }
  172.    }
  173.    
  174. eval 'tie @h, FAKEARRAY, fred' ;
  175. tie @h, FAKEARRAY, fred ;
  176. EXPECT
  177. TIEARRAY FAKEARRAY fred
  178. TIEARRAY FAKEARRAY fred
  179. DESTROY 
  180. ########
  181. BEGIN { die "phooey\n" }
  182. EXPECT
  183. phooey
  184. BEGIN failed--compilation aborted at - line 1.
  185. ########
  186. BEGIN { 1/$zero }
  187. EXPECT
  188. Illegal division by zero at - line 1.
  189. BEGIN failed--compilation aborted at - line 1.
  190. ########
  191. BEGIN { undef = 0 }
  192. EXPECT
  193. Modification of a read-only value attempted at - line 1.
  194. BEGIN failed--compilation aborted at - line 1.
  195. ########
  196. {
  197.     package foo;
  198.     sub PRINT {
  199.         shift;
  200.         print join(' ', reverse @_)."\n";
  201.     }
  202.     sub PRINTF {
  203.         shift;
  204.       my $fmt = shift;
  205.         print sprintf($fmt, @_)."\n";
  206.     }
  207.     sub TIEHANDLE {
  208.         bless {}, shift;
  209.     }
  210.     sub READLINE {
  211.     "Out of inspiration";
  212.     }
  213.     sub DESTROY {
  214.     print "and destroyed as well\n";
  215.   }
  216.   sub READ {
  217.       shift;
  218.       print STDOUT "foo->can(READ)(@_)\n";
  219.       return 100; 
  220.   }
  221.   sub GETC {
  222.       shift;
  223.       print STDOUT "Don't GETC, Get Perl\n";
  224.       return "a"; 
  225.   }    
  226. }
  227. {
  228.     local(*FOO);
  229.     tie(*FOO,'foo');
  230.     print FOO "sentence.", "reversed", "a", "is", "This";
  231.     print "-- ", <FOO>, " --\n";
  232.     my($buf,$len,$offset);
  233.     $buf = "string";
  234.     $len = 10; $offset = 1;
  235.     read(FOO, $buf, $len, $offset) == 100 or die "foo->READ failed";
  236.     getc(FOO) eq "a" or die "foo->GETC failed";
  237.     printf "%s is number %d\n", "Perl", 1;
  238. }
  239. EXPECT
  240. This is a reversed sentence.
  241. -- Out of inspiration --
  242. foo->can(READ)(string 10 1)
  243. Don't GETC, Get Perl
  244. Perl is number 1
  245. and destroyed as well
  246. ########
  247. my @a; $a[2] = 1; for (@a) { $_ = 2 } print "@a\n"
  248. EXPECT
  249. 2 2 2
  250. ########
  251. @a = ($a, $b, $c, $d) = (5, 6);
  252. print "ok\n"
  253.   if ($a[0] == 5 and $a[1] == 6 and !defined $a[2] and !defined $a[3]);
  254. EXPECT
  255. ok
  256. ########
  257. print "ok\n" if (1E2<<1 == 200 and 3E4<<3 == 240000);
  258. EXPECT
  259. ok
  260. ########
  261. print "ok\n" if ("\0" lt "\xFF");
  262. EXPECT
  263. ok
  264. ########
  265. open(H,'op/misc.t'); # must be in the 't' directory
  266. stat(H);
  267. print "ok\n" if (-e _ and -f _ and -r _);
  268. EXPECT
  269. ok
  270. ########
  271. sub thing { 0 || return qw(now is the time) }
  272. print thing(), "\n";
  273. EXPECT
  274. nowisthetime
  275. ########
  276. $ren = 'joy';
  277. $stimpy = 'happy';
  278. { local $main::{ren} = *stimpy; print $ren, ' ' }
  279. print $ren, "\n";
  280. EXPECT
  281. happy joy
  282. ########
  283. $stimpy = 'happy';
  284. { local $main::{ren} = *stimpy; print ${'ren'}, ' ' }
  285. print +(defined(${'ren'}) ? 'oops' : 'joy'), "\n";
  286. EXPECT
  287. happy joy
  288. ########
  289. package p;
  290. sub func { print 'really ' unless wantarray; 'p' }
  291. sub groovy { 'groovy' }
  292. package main;
  293. print p::func()->groovy(), "\n"
  294. EXPECT
  295. really groovy
  296. ########
  297. @list = ([ 'one', 1 ], [ 'two', 2 ]);
  298. sub func { $num = shift; (grep $_->[1] == $num, @list)[0] }
  299. print scalar(map &func($_), 1 .. 3), " ",
  300.       scalar(map scalar &func($_), 1 .. 3), "\n";
  301. EXPECT
  302. 2 3
  303. ########
  304. ($k, $s)  = qw(x 0);
  305. @{$h{$k}} = qw(1 2 4);
  306. for (@{$h{$k}}) { $s += $_; delete $h{$k} if ($_ == 2) }
  307. print "bogus\n" unless $s == 7;
  308. ########
  309. my $a = 'outer';
  310. eval q[ my $a = 'inner'; eval q[ print "$a " ] ];
  311. eval { my $x = 'peace'; eval q[ print "$x\n" ] }
  312. EXPECT
  313. inner peace
  314. ########
  315. -w
  316. $| = 1;
  317. sub foo {
  318.     print "In foo1\n";
  319.     eval 'sub foo { print "In foo2\n" }';
  320.     print "Exiting foo1\n";
  321. }
  322. foo;
  323. foo;
  324. EXPECT
  325. In foo1
  326. Subroutine foo redefined at (eval 1) line 1.
  327. Exiting foo1
  328. In foo2
  329. ########
  330. $s = 0;
  331. map {#this newline here tickles the bug
  332. $s += $_} (1,2,4);
  333. print "eat flaming death\n" unless ($s == 7);
  334. ########
  335. sub foo { local $_ = shift; split; @_ }
  336. @x = foo(' x  y  z ');
  337. print "you die joe!\n" unless "@x" eq 'x y z';
  338. ########
  339. /(?{"{"})/    # Check it outside of eval too
  340. EXPECT
  341. Sequence (?{...}) not terminated or not {}-balanced at - line 1, within pattern
  342. /(?{"{"})/: Sequence (?{...}) not terminated or not {}-balanced at - line 1.
  343. ########
  344. /(?{"{"}})/    # Check it outside of eval too
  345. EXPECT
  346. Unmatched right bracket at (re_eval 1) line 1, at end of line
  347. syntax error at (re_eval 1) line 1, near ""{"}"
  348. Compilation failed in regexp at - line 1.
  349. ########
  350. BEGIN { @ARGV = qw(a b c) }
  351. BEGIN { print "argv <@ARGV>\nbegin <",shift,">\n" }
  352. END { print "end <",shift,">\nargv <@ARGV>\n" }
  353. INIT { print "init <",shift,">\n" }
  354. EXPECT
  355. argv <a b c>
  356. begin <a>
  357. init <b>
  358. end <c>
  359. argv <>
  360. ########
  361. -l
  362. # fdopen from a system descriptor to a system descriptor used to close
  363. # the former.
  364. open STDERR, '>&=STDOUT' or die $!;
  365. select STDOUT; $| = 1; print fileno STDOUT;
  366. select STDERR; $| = 1; print fileno STDERR;
  367. EXPECT
  368. 1
  369. 2
  370. ########
  371. -w
  372. sub testme { my $a = "test"; { local $a = "new test"; print $a }}
  373. EXPECT
  374. Can't localize lexical variable $a at - line 2.
  375. ########
  376. package X;
  377. sub ascalar { my $r; bless \$r }
  378. sub DESTROY { print "destroyed\n" };
  379. package main;
  380. *s = ascalar X;
  381. EXPECT
  382. destroyed
  383. ########
  384. package X;
  385. sub anarray { bless [] }
  386. sub DESTROY { print "destroyed\n" };
  387. package main;
  388. *a = anarray X;
  389. EXPECT
  390. destroyed
  391. ########
  392. package X;
  393. sub ahash { bless {} }
  394. sub DESTROY { print "destroyed\n" };
  395. package main;
  396. *h = ahash X;
  397. EXPECT
  398. destroyed
  399. ########
  400. package X;
  401. sub aclosure { my $x; bless sub { ++$x } }
  402. sub DESTROY { print "destroyed\n" };
  403. package main;
  404. *c = aclosure X;
  405. EXPECT
  406. destroyed
  407. ########
  408. package X;
  409. sub any { bless {} }
  410. my $f = "FH000"; # just to thwart any future optimisations
  411. sub afh { select select ++$f; my $r = *{$f}{IO}; delete $X::{$f}; bless $r }
  412. sub DESTROY { print "destroyed\n" }
  413. package main;
  414. $x = any X; # to bump sv_objcount. IO objs aren't counted??
  415. *f = afh X;
  416. EXPECT
  417. destroyed
  418. destroyed
  419. ########
  420.